home *** CD-ROM | disk | FTP | other *** search
/ Turnbull China Bikeride / Turnbull China Bikeride - Disc 2.iso / STUTTGART / LANG / ADA / GNAT / !gcc / adainc / 6 / adb / s-valuti < prev    next >
Text File  |  1996-02-12  |  8KB  |  289 lines
  1. ------------------------------------------------------------------------------
  2. --                                                                          --
  3. --                         GNAT COMPILER COMPONENTS                         --
  4. --                                                                          --
  5. --                      S Y S T E M . V A L _ U T I L                       --
  6. --                                                                          --
  7. --                                 B o d y                                  --
  8. --                                                                          --
  9. --                            $Revision: 1.10 $                             --
  10. --                                                                          --
  11. --     Copyright (C) 1992,1993,1994,1995 Free Software Foundation, Inc.     --
  12. --                                                                          --
  13. -- GNAT is free software;  you can  redistribute it  and/or modify it under --
  14. -- terms of the  GNU General Public License as published  by the Free Soft- --
  15. -- ware  Foundation;  either version 2,  or (at your option) any later ver- --
  16. -- sion.  GNAT is distributed in the hope that it will be useful, but WITH- --
  17. -- OUT ANY WARRANTY;  without even the  implied warranty of MERCHANTABILITY --
  18. -- or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License --
  19. -- for  more details.  You should have  received  a copy of the GNU General --
  20. -- Public License  distributed with GNAT;  see file COPYING.  If not, write --
  21. -- to  the Free Software Foundation,  59 Temple Place - Suite 330,  Boston, --
  22. -- MA 02111-1307, USA.                                                      --
  23. --                                                                          --
  24. -- As a special exception,  if other files  instantiate  generics from this --
  25. -- unit, or you link  this unit with other files  to produce an executable, --
  26. -- this  unit  does not  by itself cause  the resulting  executable  to  be --
  27. -- covered  by the  GNU  General  Public  License.  This exception does not --
  28. -- however invalidate  any other reasons why  the executable file  might be --
  29. -- covered by the  GNU Public License.                                      --
  30. --                                                                          --
  31. -- GNAT was originally developed  by the GNAT team at  New York University. --
  32. -- It is now maintained by Ada Core Technologies Inc (http://www.gnat.com). --
  33. --                                                                          --
  34. ------------------------------------------------------------------------------
  35.  
  36. with GNAT.Case_Util; use GNAT.Case_Util;
  37.  
  38. package body System.Val_Util is
  39.  
  40.    ----------------------
  41.    -- Normalize_String --
  42.    ----------------------
  43.  
  44.    procedure Normalize_String
  45.      (S    : in out String;
  46.       F, L : out Positive'Base)
  47.    is
  48.    begin
  49.       F := S'First;
  50.       L := S'Last;
  51.  
  52.       --  Scan for leading spaces
  53.  
  54.       while F <= L and then S (F) = ' ' loop
  55.          F := F + 1;
  56.       end loop;
  57.  
  58.       --  Check for case when the string contained no characters
  59.  
  60.       if F > L then
  61.          raise Constraint_Error;
  62.       end if;
  63.  
  64.       --  Scan for trailing spaces
  65.  
  66.       while S (L) = ' ' loop
  67.          L := L - 1;
  68.       end loop;
  69.  
  70.       --  Except in the case of a character literal, convert to upper case
  71.  
  72.       if S (F) /= ''' then
  73.          for J in F .. L loop
  74.             S (J) := To_Upper (S (J));
  75.          end loop;
  76.       end if;
  77.  
  78.    end Normalize_String;
  79.  
  80.    ---------------
  81.    -- Scan_Sign --
  82.    ---------------
  83.  
  84.    procedure Scan_Sign
  85.      (Str   : String;
  86.       Ptr   : access Positive'Base;
  87.       Max   : Positive'Base;
  88.       Minus : out Boolean;
  89.       Start : out Positive)
  90.    is
  91.       P : Natural := Ptr.all;
  92.  
  93.    begin
  94.       --  Deal with case of null string (all blanks!). As per spec, we
  95.       --  raise constraint error, with Ptr unchanged, and thus > Max.
  96.  
  97.       if P > Max then
  98.          raise Constraint_Error;
  99.       end if;
  100.  
  101.       --  Scan past initial blanks
  102.  
  103.       while Str (P) = ' ' loop
  104.          P := P + 1;
  105.  
  106.          if P > Max then
  107.             Ptr.all := P;
  108.             raise Constraint_Error;
  109.          end if;
  110.       end loop;
  111.  
  112.       Start := P;
  113.  
  114.       --  Remember an initial minus sign
  115.  
  116.       if Str (P) = '-' then
  117.          Minus := True;
  118.          P := P + 1;
  119.  
  120.          if P > Max then
  121.             Ptr.all := Start;
  122.             raise Constraint_Error;
  123.          end if;
  124.  
  125.       --  Skip past an initial plus sign
  126.  
  127.       elsif Str (P) = '+' then
  128.          Minus := False;
  129.          P := P + 1;
  130.  
  131.          if P > Max then
  132.             Ptr.all := Start;
  133.             raise Constraint_Error;
  134.          end if;
  135.  
  136.       else
  137.          Minus := False;
  138.       end if;
  139.  
  140.       Ptr.all := P;
  141.    end Scan_Sign;
  142.  
  143.    -------------------
  144.    -- Scan_Exponent --
  145.    -------------------
  146.  
  147.    function Scan_Exponent
  148.      (Str  : String;
  149.       Ptr  : access Positive'Base;
  150.       Max  : Positive'Base;
  151.       Real : Boolean := False)
  152.       return Integer
  153.    is
  154.       P : Natural := Ptr.all;
  155.       M : Boolean;
  156.       X : Integer;
  157.  
  158.    begin
  159.       if P >= Max
  160.         or else (Str (P) /= 'E' and then Str (P) /= 'e')
  161.       then
  162.          return 0;
  163.       end if;
  164.  
  165.       --  We have an E/e, see if sign follows
  166.  
  167.       P := P + 1;
  168.  
  169.       if Str (P) = '+' then
  170.          P := P + 1;
  171.  
  172.          if P > Max then
  173.             return 0;
  174.          else
  175.             M := False;
  176.          end if;
  177.  
  178.       elsif Str (P) = '-' then
  179.          P := P + 1;
  180.  
  181.          if P > Max or else not Real then
  182.             return 0;
  183.          else
  184.             M := True;
  185.          end if;
  186.  
  187.       else
  188.          M := False;
  189.       end if;
  190.  
  191.       if Str (P) not in '0' .. '9' then
  192.          return 0;
  193.       end if;
  194.  
  195.       --  Scan out the exponent value as an unsigned integer. Values larger
  196.       --  than (Integer'Last / 10) are simply considered large enough here.
  197.       --  This assumption is correct for all machines we know of (e.g. in
  198.       --  the case of 16 bit integers it allows exponents up to 3276, which
  199.       --  is large enough for the largest floating types in base 2.)
  200.  
  201.       X := 0;
  202.  
  203.       loop
  204.          if X < (Integer'Last / 10) then
  205.             X := X * 10 + (Character'Pos (Str (P)) - Character'Pos ('0'));
  206.             P := P + 1;
  207.          end if;
  208.  
  209.          exit when P > Max;
  210.  
  211.          if Str (P) = '_' then
  212.             Scan_Underscore (Str, P, Ptr, Max, False);
  213.          else
  214.             exit when Str (P) not in '0' .. '9';
  215.          end if;
  216.       end loop;
  217.  
  218.       if M then
  219.          X := -X;
  220.       end if;
  221.  
  222.       Ptr.all := P;
  223.       return X;
  224.  
  225.    end Scan_Exponent;
  226.  
  227.    --------------------------
  228.    -- Scan_Trailing_Blanks --
  229.    --------------------------
  230.  
  231.    procedure Scan_Trailing_Blanks (Str : String; P : Positive) is
  232.    begin
  233.       for J in P .. Str'Last loop
  234.          if Str (J) /= ' ' then
  235.             raise Constraint_Error;
  236.          end if;
  237.       end loop;
  238.    end Scan_Trailing_Blanks;
  239.  
  240.    ---------------------
  241.    -- Scan_Underscore --
  242.    ---------------------
  243.  
  244.    procedure Scan_Underscore
  245.      (Str : String;
  246.       P   : in out Natural;
  247.       Ptr : access Integer;
  248.       Max : Integer;
  249.       Ext : Boolean)
  250.    is
  251.       C : Character;
  252.  
  253.    begin
  254.       P := P + 1;
  255.  
  256.       --  If underscore is at the end of string, then this is an error and
  257.       --  we raise Constraint_Error, leaving the pointer past the undescore.
  258.       --  This seems a bit strange. It means e,g, that if the field is:
  259.  
  260.       --    345_
  261.  
  262.       --  that Constraint_Error is raised. You might think that the RM in
  263.       --  this case would scan out the 345 as a valid integer, leaving the
  264.       --  pointer at the underscore, but the ACVC suite clearly requires
  265.       --  an error in this situation (see for example CE3704M).
  266.  
  267.       if P > Max then
  268.          Ptr.all := P;
  269.          raise Constraint_Error;
  270.       end if;
  271.  
  272.       --  Similarly, if no digit follows the underscore raise an error. This
  273.       --  also catches the case of double underscore which is also an error.
  274.  
  275.       C := Str (P);
  276.  
  277.       if C in '0' .. '9'
  278.         or else
  279.           (Ext and then (C in 'A' .. 'F' or else C in 'a' .. 'f'))
  280.       then
  281.          return;
  282.       else
  283.          Ptr.all := P;
  284.          raise Constraint_Error;
  285.       end if;
  286.    end Scan_Underscore;
  287.  
  288. end System.Val_Util;
  289.